home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / batch.scm < prev    next >
Text File  |  1999-04-19  |  15KB  |  447 lines
  1. ;;; "batch.scm" Group and execute commands on various systems.
  2. ;Copyright (C) 1994, 1995, 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'line-i/o)            ;Just for write-line
  21. (require 'parameters)
  22. (require 'database-utilities)
  23. (require 'string-port)
  24. (require 'tree)
  25.  
  26. (define system
  27.   (if (provided? 'system)
  28.       system
  29.       (lambda (str) 1)))
  30. (define system:success?
  31.   (case (software-type)
  32.     ((VMS) (lambda (int) (eqv? 1 int)))
  33.     (else zero?)))
  34. ;;(trace system system:success? exit quit slib:exit)
  35.  
  36. (define (batch:port parms)
  37.   (let ((bp (parameter-list-ref parms 'batch-port)))
  38.     (cond ((or (not (pair? bp)) (not (output-port? (car bp))))
  39.        (slib:warn 'batch-line "missing batch-port parameter" bp)
  40.        (current-output-port))
  41.       (else (car bp)))))
  42.  
  43. (define (batch:dialect parms)        ; was batch-family
  44.   (car (parameter-list-ref parms 'batch-dialect)))
  45.  
  46. (define (batch:line-length-limit parms)
  47.   (let ((bl (parameter-list-ref parms 'batch-line-length-limit)))
  48.     (cond (bl (car bl))
  49.       (else (case (batch:dialect parms)
  50.           ((unix) 1023)
  51.           ((dos) 127)
  52.           ((vms) 1023)
  53.           ((amigados) 511)
  54.           ((system) 1023)
  55.           ((*unknown*) -1))))))
  56.  
  57. (define (write-batch-line str line-limit port)
  58.   (cond ((and line-limit (>= (string-length str) line-limit)) #f)
  59.     (else (write-line str port) #t)))
  60. (define (batch-line parms str)
  61.   (write-batch-line str (batch:line-length-limit parms) (batch:port parms)))
  62.  
  63. ;;; add a Scheme batch-dialect?
  64.  
  65. (define (batch:apply-chop-to-fit proc . args)
  66.   (define args-but-last (butlast args 1))
  67.   (let loop ((fodder (car (last-pair args))))
  68.     (let ((hlen (quotient (length fodder) 2)))
  69.       (cond ((apply proc (append args-but-last (list fodder))))
  70.         ((not (positive? hlen))
  71.          (slib:error 'batch:apply-chop-to-fit "can't split"
  72.              (cons proc (append args-but-last (list fodder)))))
  73.         (else (loop (nthcdr (- (length fodder) hlen) fodder))
  74.           (loop (butlast fodder hlen)))))))
  75.  
  76. (define (batch:try-system parms . strings)
  77.   (set! strings (batch:flatten strings))
  78.   (case (batch:dialect parms)
  79.     ((unix) (batch-line parms (apply string-join " " strings)))
  80.     ((dos) (batch-line parms (apply string-join " " strings)))
  81.     ((vms) (batch-line parms (apply string-join " " "$" strings)))
  82.     ((amigados) (batch-line parms (apply string-join " " strings)))
  83.     ((system)
  84.      (let ((port (batch:port parms))
  85.        (str (apply string-join " " strings)))
  86.        (write `(system ,str) port) (newline port)
  87.        (and (provided? 'system) (system:success? (system str)))))
  88.     ((*unknown*)
  89.      (let ((port (batch:port parms))
  90.        (str (apply string-join " " strings)))
  91.        (write `(system ,str) port) (newline port))
  92.      #t)
  93.     (else #f)))
  94.  
  95. (define (batch:system parms . strings)
  96.   (cond ((apply batch:try-system parms strings))
  97.     (else (slib:error 'batch:system 'failed strings))))
  98.  
  99. (define (batch:run-script parms name . strings)
  100.   (case (batch:dialect parms strings)
  101.     ((vms) (batch:system parms (string-append "@" name) strings))
  102.     (else (batch:system parms name strings))))
  103.  
  104. (define (batch:write-comment-line dialect line port)
  105.   (case dialect
  106.     ((unix) (write-batch-line (string-append "# " line) #f port))
  107.     ((dos) (write-batch-line (string-append "rem " line) #f port))
  108.     ((vms) (write-batch-line (string-append "$! " line) #f port))
  109.     ((amigados) (write-batch-line (string-append "; " line) #f port))
  110.     ((system) (write-batch-line (string-append "; " line) #f port))
  111.     ((*unknown*) (write-batch-line (string-append ";;; " line) #f port)
  112.      ;;(newline port)
  113.      #f)))
  114.  
  115. (define (batch:comment parms . lines)
  116.   (define port (batch:port parms))
  117.   (define dialect (batch:dialect parms))
  118.   (set! lines (batch:flatten lines))
  119.   (every (lambda (line)
  120.        (batch:write-comment-line dialect line port))
  121.      lines))
  122.  
  123. (define (batch:lines->file parms file . lines)
  124.   (define port (batch:port parms))
  125.   (set! lines (batch:flatten lines))
  126.   (case (or (batch:dialect parms) '*unknown*)
  127.     ((unix) (batch-line parms (string-append "rm -f " file))
  128.         (every
  129.          (lambda (string)
  130.            (batch-line parms (string-append "echo '" string "'>>" file)))
  131.          lines))
  132.     ((dos) (batch-line parms (string-append "DEL " file))
  133.        (every
  134.         (lambda (string)
  135.           (batch-line parms
  136.               (string-append "ECHO" (if (equal? "" string) "." " ")
  137.                      string ">>" file)))
  138.         lines))
  139.     ((vms) (and (batch-line parms (string-append "$DELETE " file))
  140.         (batch-line parms (string-append "$CREATE " file))
  141.         (batch-line parms (string-append "$DECK"))
  142.         (every (lambda (string) (batch-line parms string))
  143.                lines)
  144.         (batch-line parms (string-append "$EOD"))))
  145.     ((amigados) (batch-line parms (string-append "delete force " file))
  146.         (every
  147.          (lambda (str)
  148.            (letrec ((star-quote
  149.              (lambda (str)
  150.                (if (equal? "" str)
  151.                    str
  152.                    (let* ((ch (string-ref str 0))
  153.                       (s (if (char=? ch #\")
  154.                          (string #\* ch)
  155.                          (string ch))))
  156.                  (string-append
  157.                   s
  158.                   (star-quote
  159.                    (substring str 1 (string-length str)))))))))
  160.          (batch-line parms (string-append "echo \"" (star-quote str) 
  161.                           "\" >> " file))))
  162.          lines))
  163.     ((system) (write `(delete-file ,file) port) (newline port)
  164.           (delete-file file)
  165.           (require 'pretty-print)
  166.           (pretty-print `(call-with-output-file ,file
  167.                    (lambda (fp)
  168.                  (for-each
  169.                   (lambda (string) (write-line string fp))
  170.                   ',lines)))
  171.                 port)
  172.           (call-with-output-file file
  173.         (lambda (fp) (for-each (lambda (string) (write-line string fp))
  174.                        lines)))
  175.           #t)
  176.     ((*unknown*)
  177.      (write `(delete-file ,file) port) (newline port)
  178.      (require 'pretty-print)
  179.      (pretty-print
  180.       `(call-with-output-file ,file
  181.      (lambda (fp)
  182.        (for-each
  183.         (lambda (string)
  184.           (write-line string fp))
  185.         ,lines)))
  186.       port)
  187.      #f)))
  188.  
  189. (define (batch:delete-file parms file)
  190.   (define port (batch:port parms))
  191.   (case (batch:dialect parms)
  192.     ((unix) (batch-line parms (string-append "rm -f " file))
  193.         #t)
  194.     ((dos) (batch-line parms (string-append "DEL " file))
  195.        #t)
  196.     ((vms) (batch-line parms (string-append "$DELETE " file))
  197.        #t)
  198.     ((amigados) (batch-line parms (string-append "delete force " file))
  199.         #t)
  200.     ((system) (write `(delete-file ,file) port) (newline port)
  201.           (delete-file file))    ; SLIB provides
  202.     ((*unknown*) (write `(delete-file ,file) port) (newline port)
  203.          #f)))
  204.  
  205. (define (batch:rename-file parms old-name new-name)
  206.   (define port (batch:port parms))
  207.   (case (batch:dialect parms)
  208.     ((unix) (batch-line parms (string-join " " "mv -f" old-name new-name)))
  209.     ;;((dos) (batch-line parms (string-join " " "REN" old-name new-name)))
  210.     ((dos) (batch-line parms (string-join " " "MOVE" "/Y" old-name new-name)))
  211.     ((vms) (batch-line parms (string-join " " "$RENAME" old-name new-name)))
  212.     ((amigados) (batch-line parms (string-join " " "failat 21"))
  213.         (batch-line parms (string-join " " "delete force" new-name))
  214.         (batch-line parms (string-join " " "rename" old-name new-name)))
  215.     ((system) (batch:extender 'rename-file batch:rename-file))
  216.     ((*unknown*) (write `(rename-file ,old-name ,new-name) port)
  217.          (newline port)
  218.          #f)))
  219.  
  220. (define (batch:write-header-comment dialect name port)
  221.   (batch:write-comment-line
  222.    dialect
  223.    (string-append (if (string? name)
  224.               (string-append "\"" name "\"")
  225.               (case dialect
  226.             ((system *unknown*) "Scheme")
  227.             ((vms) "VMS")
  228.             ((dos) "DOS")
  229.             ((default-for-platform) "??")
  230.             (else (symbol->string dialect))))
  231.           " script created by SLIB/batch "
  232.           (cond ((provided? 'bignum)
  233.              (require 'posix-time)
  234.              (let ((ct (ctime (current-time))))
  235.                (substring ct 0 (+ -1 (string-length ct)))))
  236.             (else "")))
  237.    port))
  238.  
  239. (define (batch:call-with-output-script parms name proc)
  240.   (define dialect (batch:dialect parms))
  241.   (case dialect
  242.     ((unix) ((cond ((and (string? name) (provided? 'system))
  243.             (lambda (proc)
  244.               (let ((ans (call-with-output-file name proc)))
  245.             (system (string-append "chmod +x " name))
  246.             ans)))
  247.            ((output-port? name) (lambda (proc) (proc name)))
  248.            (else (lambda (proc) (proc (current-output-port)))))
  249.          (lambda (port)
  250.            (write-line "#!/bin/sh" port)
  251.            (batch:write-header-comment dialect name port)
  252.            (proc port))))
  253.  
  254.     ((dos) ((cond ((string? name)
  255.            (lambda (proc)
  256.              (call-with-output-file (string-append name ".bat") proc)))
  257.           ((output-port? name) (lambda (proc) (proc name)))
  258.           (else (lambda (proc) (proc (current-output-port)))))
  259.         (lambda (port)
  260.           (batch:write-header-comment dialect name port)
  261.           (proc port))))
  262.  
  263.     ((vms) ((cond ((string? name)
  264.            (lambda (proc)
  265.              (call-with-output-file (string-append name ".COM") proc)))
  266.           ((output-port? name) (lambda (proc) (proc name)))
  267.           (else (lambda (proc) (proc (current-output-port)))))
  268.         (lambda (port)
  269.           (batch:write-header-comment dialect name port)
  270.           ;;(write-line "$DEFINE/USER SYS$OUTPUT BUILD.LOG" port)
  271.           (proc port))))
  272.  
  273.     ((amigados) ((cond ((and (string? name) (provided? 'system))
  274.             (lambda (proc)
  275.               (let ((ans (call-with-output-file name proc)))
  276.             (system (string-append "protect " name " rswd"))
  277.             ans)))
  278.            ((output-port? name) (lambda (proc) (proc name)))
  279.            (else (lambda (proc) (proc (current-output-port)))))
  280.          (lambda (port)
  281.            (batch:write-header-comment dialect name port)
  282.            (proc port))))
  283.  
  284.     ((system) ((cond ((and (string? name) (provided? 'system))
  285.               (lambda (proc)
  286.             (let ((ans (call-with-output-file name
  287.                      (lambda (port) (proc name)))))
  288.               (system (string-append "chmod +x " name))
  289.               ans)))
  290.              ((output-port? name) (lambda (proc) (proc name)))
  291.              (else (lambda (proc) (proc (current-output-port)))))
  292.            (lambda (port)
  293.          (batch:write-header-comment dialect name port)
  294.          (proc port))))
  295.  
  296.     ((*unknown*) ((cond ((and (string? name) (provided? 'system))
  297.              (lambda (proc)
  298.                (let ((ans (call-with-output-file name
  299.                     (lambda (port) (proc name)))))
  300.                  (system (string-append "chmod +x " name))
  301.                  ans)))
  302.             ((output-port? name) (lambda (proc) (proc name)))
  303.             (else (lambda (proc) (proc (current-output-port)))))
  304.           (lambda (port)
  305.             (batch:write-header-comment dialect name port)
  306.             (proc port))))))
  307.  
  308. ;;; This little ditty figures out how to use a Scheme extension or
  309. ;;; SYSTEM to execute a command that is not available in the batch
  310. ;;; mode chosen.
  311.  
  312. (define (batch:extender NAME BATCHER)
  313.   (lambda (parms . args)
  314.     (define port (batch:port parms))
  315.     (cond
  316.      ((provided? 'i/o-extensions)    ; SCM specific
  317.       (write `(,NAME ,@args) port)
  318.       (newline port)
  319.       (apply (slib:eval NAME) args))
  320.      ((not (provided? 'system)) #f)
  321.      (else
  322.       (let ((pl (make-parameter-list (map car parms))))
  323.     (adjoin-parameters!
  324.      pl (cons 'batch-dialect (os->batch-dialect
  325.                   (parameter-list-ref parms 'platform))))
  326.     (system
  327.      (call-with-output-string
  328.       (lambda (port)
  329.         (batch:call-with-output-script
  330.          port
  331.          (lambda (batch-port)
  332.            (define new-parms (copy-tree pl))
  333.            (adjoin-parameters! new-parms (list 'batch-port batch-port))
  334.            (apply BATCHER new-parms args)))))))))))
  335.  
  336. (define (truncate-up-to str chars)
  337.   (define (tut str)
  338.     (do ((i (string-length str) (+ -1 i)))
  339.     ((or (zero? i) (memv (string-ref str (+ -1 i)) chars))
  340.      (substring str i (string-length str)))))
  341.   (cond ((char? chars) (set! chars (list chars)))
  342.     ((string? chars) (set! chars (string->list chars))))
  343.   (if (string? str) (tut str) (map tut str)))
  344.  
  345. (define (must-be-first firsts lst)
  346.   (append (remove-if-not (lambda (i) (member i lst)) firsts)
  347.       (remove-if (lambda (i) (member i firsts)) lst)))
  348.  
  349. (define (must-be-last lst lasts)
  350.   (append (remove-if (lambda (i) (member i lasts)) lst)
  351.       (remove-if-not (lambda (i) (member i lst)) lasts)))
  352.  
  353. (define (string-join joiner . args)
  354.   (if (null? args) ""
  355.       (apply string-append
  356.          (car args)
  357.          (map (lambda (s) (string-append joiner s)) (cdr args)))))
  358.  
  359. (define (batch:flatten strings)
  360.   (apply
  361.    append (map
  362.        (lambda (obj)
  363.          (cond ((eq? "" obj) '())
  364.            ((string? obj) (list obj))
  365.            ((eq? #f obj) '())
  366.            ((null? obj) '())
  367.            ((list? obj) (batch:flatten obj))
  368.            (else (slib:error 'batch:flatten "unexpected type"
  369.                      obj "in" strings))))
  370.        strings)))
  371.  
  372. (define batch:platform (software-type))
  373. (cond ((and (eq? 'unix batch:platform) (provided? 'system))
  374.        (let ((file-name (tmpnam)))
  375.      (system (string-append "uname > " file-name))
  376.      (set! batch:platform (call-with-input-file file-name read))
  377.      (delete-file file-name))))
  378.  
  379. (define batch:database #f)
  380. (define (os->batch-dialect os)
  381.   ((((batch:database 'open-table) 'operating-system #f)
  382.     'get 'os-family) os))
  383.  
  384. (define (batch:initialize! database)
  385.   (set! batch:database database)
  386.   (define-tables database
  387.  
  388.     '(batch-dialect
  389.       ((family atom))
  390.       ()
  391.       ((unix)
  392.        (dos)
  393.        (vms)
  394.        (amigados)
  395.        (system)
  396.        (*unknown*)))
  397.  
  398.     '(operating-system
  399.       ((name symbol))
  400.       ((os-family batch-dialect))
  401.       (;;(3b1        *unknown*)
  402.        (*unknown*    *unknown*)
  403.        (acorn        *unknown*)
  404.        (aix        unix)
  405.        (alliant        *unknown*)
  406.        (amiga        amigados)
  407.        (apollo        unix)
  408.        (apple2        *unknown*)
  409.        (arm        *unknown*)
  410.        (atari.st    *unknown*)
  411.        (cdc        *unknown*)
  412.        (celerity    *unknown*)
  413.        (concurrent    *unknown*)
  414.        (convex        *unknown*)
  415.        (encore        *unknown*)
  416.        (harris        *unknown*)
  417.        (hp-ux        unix)
  418.        (hp48        *unknown*)
  419.        (irix        unix)
  420.        (isis        *unknown*)
  421.        (linux        unix)
  422.        (mac        *unknown*)
  423.        (masscomp    unix)
  424.        (mips        *unknown*)
  425.        (ms-dos        dos)
  426.        (ncr        *unknown*)
  427.        (newton        *unknown*)
  428.        (next        unix)
  429.        (novell        *unknown*)
  430.        (os/2        dos)
  431.        (osf1        unix)
  432.        (prime        *unknown*)
  433.        (psion        *unknown*)
  434.        (pyramid        *unknown*)
  435.        (sequent        *unknown*)
  436.        (sgi        *unknown*)
  437.        (stratus        *unknown*)
  438.        (sunos        unix)
  439.        (transputer    *unknown*)
  440.        (unicos        unix)
  441.        (unix        unix)
  442.        (vms        vms)
  443.        )))
  444.  
  445.   ((database 'add-domain) '(operating-system operating-system #f symbol #f))
  446.   )
  447.